PC-Blue - MS DOS Public Domain Library/PC-Blue MS-DOS Public Domain Library - NYACC.iso/vol177/public.pas

Pascal/Delphi Source File | 1986-11-25 | 15.3 KB | 553 lines

PROGRAM public_domain;
{ This program was written to  ease my task of Librarian of the Melbourne,
  Australia, P-C  User`s Group.  For further details refer to the .DOC file
  which should also be on this disk.   It is hereby placed into the Public
  Domain on the strict understanding that it will not be used for commercial
  gain.        David L. Jitts
               24 Regent Street, East Brighton, 3187.
               AUSTRALIA.  }


                     {  MAIN DECLARATIONS. }

CONST
title1 = 'MELBOURNE P-C USER`S GROUP';       {Title on Disk Labels}
title2 = ' Public Domain Software';          {        ditto       }
label_printer = 2;           {i.e. LPT2: If both printers are the same then}
paper_printer = 1;           {program will prompt user to change paper type}
width = 42;               {Label width pitch = 42 chars.}
lab_length = 9;           {Label length pitch = 9 print lines}
drive = 'B:';             {Drive for disk file if /D parameter switch
                           has been included in command line }

TYPE
vol_type  = STRING[15];
line_type = STRING[80];
data_type = STRING[25];
pointr = ^labl;
labl  = RECORD
            volume    : vol_type;
            order_no  : INTEGER;
            next_lab  : pointr;
          END;
toe    = ^buyer;
buyer  = RECORD
            name     : data_type;
            adres1   : data_type;
            adres2   : data_type;
            adres3   : data_type;
            orderno  : INTEGER;
            next_buy : toe;
          END;
datestr = STRING[8];

VAR
library : vol_type;
order, X : INTEGER;
buylist, buytail : toe;
lablist, labtail : pointr;
bold_on, bold_off : STRING[2];
pline : ARRAY[1..9] OF line_type;
blank_line : line_type;
disk_count : INTEGER;
anykey : CHAR;
to_disk : BOOLEAN;

         { ************************************************** }

FUNCTION date : datestr;

TYPE
  regpack = RECORD
              ax,bx,cx,dx,bp,si,di,ds,es,flags: INTEGER;
            END;

VAR
  recpack:       regpack;                {record for MsDos call}
  month,day:     STRING[2];
  year:          STRING[4];
  dx,cx:         INTEGER;

BEGIN
  WITH recpack DO
  BEGIN
    ax := $2A SHL 8;
  END;
  MsDos(recpack);                        { call function }
  WITH recpack DO
  BEGIN
    STR(cx,year);                    {convert to string}
    STR(dx mod 256,day);                     { " }
    STR(dx shr 8,month);                     { " }
  END;
  date := day+'-'+month+'-'+COPY(year,3,2);  {In British date format}
END;   {of date}

              { ****************************************** }

PROCEDURE select_printer(lpt : INTEGER);
{ Selects which of LPT1 or LPT2 corresponds to LST}

BEGIN
CASE  lpt   OF
  1: BEGIN
       MEM[0000:$408] := 188;
       MEM[0000:$409] :=   3;
       MEM[0000:$40A] := 193;
       MEM[0000:$40B] :=   0;
     END;
  2: BEGIN
       MEM[0000:$408] := 193;
       MEM[0000:$409] :=   0;
       MEM[0000:$40A] := 188;
       MEM[0000:$40B] :=   3;
     END;
  ELSE  WRITE(CHR(7), 'ILLEGAL PRINTER');
END;  {of CASE}
END;  {of select_printer}

              { ****************************************** }


PROCEDURE initialise;

BEGIN
IF (ParamSTR(1) = '/D') OR (ParamStr(1) = '/d') THEN
         to_disk := TRUE
  ELSE   to_disk := FALSE;
bold_on := CHR(27) + '!';           {Not used in this version}
bold_off := CHR(27) + '"';          {        ditto           }
order := 1;
blank_line := '';
FOR X := 1 TO width DO
   blank_line := blank_line + ' ';
FOR X := 1 TO lab_length DO
   pline[X] := ' ';
lablist := NIL;
buylist := NIL;
disk_count := 0;
END;   {of initialise}

              {  ***************************************** }

PROCEDURE banner;


BEGIN
CLRSCR;
GOTOXY(2,4); WRITELN('THE PUBLIC DOMAIN SOFTWARE LABELLER');
WRITELN;
WRITELN('     This program has the following built-in constants:');
WRITELN('           Labels sent to LPT',label_printer,':');
IF to_disk THEN
    WRITELN('           Lists sent to disk on Drive ',drive)
  ELSE
    WRITELN('           Lists sent to LPT',paper_printer,':');
WRITELN('           Labels set for 2 across the sheet.');
WRITELN('           Label width pitch  = ',width, ' characters');
WRITELN('           Label length pitch =  ', lab_length, ' print lines');
WRITELN;
WRITELN('                Hit any Key to continue'); READ(Kbd, anykey);
END;   {of banner}



              { ****************************************** }

PROCEDURE get_labls;

VAR
new_labl : pointr;
X, Y : INTEGER;
in_labl : vol_type;

BEGIN
X := 5; Y := 12;
GOTOXY(10,9); WRITE('ENTER THE REQUIRED VOLUMES.');
              WRITE('ENTER "*" TO ABORT ENTRIES');
GOTOXY(10,10); WRITE('Rules: Max Vol Length 15, 4th character must be blank');
in_labl := ' ';
WHILE in_labl <> '*' DO
 BEGIN
  GOTOXY(X,Y);WRITE('? ');READ(in_labl);
  IF in_labl = '*' THEN EXIT;      {Abort entry mode}
  IF  (LENGTH(in_labl) > 15) OR (COPY(in_labl, 4,1) <> ' ') THEN
     BEGIN
        WRITE(CHR(7));   {Beep, erase and loop if it doesn`t match the rules}
        GOTOXY(X,Y);WRITE('                    ');
     END
   ELSE                 {Process  the entry}
     BEGIN
       disk_count := disk_count + 1;
       NEW(new_labl);
       WITH new_labl^ DO
         BEGIN
           volume  := in_labl;
           order_no := order;
           next_lab :=  NIL;
           IF lablist = NIL THEN
               lablist := new_labl
             ELSE labtail^.next_lab := new_labl;
         END;  {of WITH new_labl}
       labtail := new_labl;
       in_labl := ' ';
       X := X + 18;
       IF X > 70 THEN
         BEGIN
           Y := Y + 1;
           X := 5;
          END;
      END;  {of IF in_labl}
   END;  {of WHILE}
END;   {of get_labls}

             { ********************************************* }

PROCEDURE get_buyer;

VAR
newbuyer    : toe;
in_name     : data_type;
in_adres1   : data_type;
in_adres2   : data_type;
in_adres3   : data_type;
reply, answer    : CHAR;
Y : INTEGER;

FUNCTION in_data : data_type;

LABEL loop;

VAR
response : STRING[26];

BEGIN
response := '';
loop: GOTOXY(25,Y); READLN(response);
      IF LENGTH(response) > 25 THEN
        BEGIN
           WRITE(CHR(7));
           GOTOXY(25,Y);ClrEol;
           GOTOXY(50,Y); WRITE(CHR(27),'- No entries past here');
           GOTO loop;
         END;
in_data := response;
Y := Y + 1;
END;  {of FUNCTION}

BEGIN
reply := ' ';
WHILE reply <> 'Y' DO
  BEGIN
    CLRSCR;
    GOTOXY(10,2); WRITE('PROCESSING ORDER No.: ', order);
    GOTOXY(50,4); WRITE(CHR(27),'- No entries past here');
    Y := 4;
    GOTOXY(10,Y); WRITE('Buyer`s Name: ');in_name := in_data;
    GOTOXY(10,Y); WRITE('Address    1: ');in_adres1 := in_data;
    GOTOXY(10,Y); WRITE('           2: ');in_adres2 := in_data;
    GOTOXY(10,Y); WRITE('           3: ');in_adres3 := in_data;
    WHILE NOT (reply IN ['Y','N']) DO
      BEGIN
         GOTOXY(10,9); WRITE('Above Entries OK? Y/N ');READ(Kbd, reply);
         reply := UPCASE(reply);
         IF NOT (reply IN ['Y','N']) THEN WRITE(CHR(7));
      END;
    IF reply = 'Y' THEN
      BEGIN
        GOTOXY(10,9);WRITE('                     ');
        NEW(newbuyer);
        WITH newbuyer^ DO
          BEGIN
            name   := in_name;
            adres1 := in_adres1;
            adres2 := in_adres2;
            adres3 := in_adres3;
            orderno := order;
            next_buy :=  NIL;
            IF buylist = NIL THEN
                 buylist := newbuyer
            ELSE
                buytail^.next_buy := newbuyer;
          END;   {of WITH newbuyer}
          buytail := newbuyer;
       END
     ELSE get_buyer;
  END;  {of WHILE reply}
  get_labls;
  CLRSCR;
  answer := ' ';
  WHILE NOT (answer IN ['Y','N']) DO
    BEGIN
      GOTOXY(10,10);WRITE('Another Order ? Y/N '); READ(Kbd, answer);
      answer := UPCASE(answer);
      IF NOT (answer IN ['Y','N']) THEN WRITE(CHR(7));
    END;
  IF answer = 'Y' THEN
    BEGIN
       order := order + 1;
       get_buyer;
    END;   {of IF reply}
END;  {of get_buyer}

           { ******************************************* }

PROCEDURE sortlabls;

VAR
unfinished : BOOLEAN;
temp_vol : vol_type;
finger : pointr;

BEGIN
unfinished := TRUE;
WHILE  unfinished DO
   BEGIN
      finger := lablist;
      unfinished := FALSE;
      while finger^.next_lab <> NIL do
         begin
           if (finger^.volume > finger^.next_lab^.volume) THEN
             BEGIN
               temp_vol := finger^.next_lab^.volume;
               finger^.next_lab^.volume := finger^.volume;
               finger^.volume  := temp_vol;
               unfinished := true;
             END;
             finger := finger^.next_lab;
          END; {WHILE finger}
    END; {while unfinished}
END;

   { ***************************************************** }

PROCEDURE print_plines;

VAR
X : INTEGER;

BEGIN
FOR X := 1 TO lab_length DO
  BEGIN
     WRITELN(LST, pline[X]);
     pline[X] := ' ';
  END; {of FOR}
END;   {of print_plines}

              { ******************************************* }

PROCEDURE print_mail_labls;

VAR
next : toe;
refer : data_type;
left : BOOLEAN;
margin : INTEGER;
order_str : STRING[4];

BEGIN
next := buylist;
left := TRUE;                     {start on the left}
WHILE next <> NIL DO
  BEGIN
     WITH next^ DO
       BEGIN
          STR(orderno, order_str);
          refer := '   Ref: ' + date  + ' #' + order_str;
          IF left THEN BEGIN
             pline[1] := name;
             pline[2] := adres1;
             pline[3] := adres2;
             pline[4] := adres3;
             pline[6] := refer;
             FOR X := 1 TO lab_length DO
              BEGIN
                 pline[X] := pline[X] + blank_line;
                 DELETE(pline[X],width,width);
              END;  {of FOR X}
           END   {of IF left}
          ELSE BEGIN
             pline[1] := pline[1] + name;
             pline[2] := pline[2] + adres1;
             pline[3] := pline[3] + adres2;
             pline[4] := pline[4] + adres3;
             pline[6] := pline[6] + refer;
           END;  {of ELSE}
          next := next_buy;
          IF NOT left THEN print_plines;
          left := NOT left;          {i.e. swap position flag}
        END;   {of WITH next^}
   END;   {of WHILE next}
IF NOT left THEN print_plines;       {in case there was an odd number}
END;   {of print_mail_labels}

           { ********************************************* }

PROCEDURE print_disk_labls;

VAR
next : pointr;
refer : data_type;
left : BOOLEAN;
margin : INTEGER;
order_str : STRING[4];

BEGIN
next := lablist;
left := TRUE;
WHILE next <> NIL DO
  BEGIN
     WITH next^ DO
       BEGIN
          STR(order_no, order_str);
          refer := '   Ref: ' + date  + ' #' + order_str;
          IF left THEN BEGIN
             pline[1] := title1;
             pline[2] := title2;
             pline[4] := 'Volume: ' + volume;
             pline[6] := refer;
             FOR X := 1 to 6 DO BEGIN
                 pline[X] := pline[X] + blank_line;
                 DELETE(pline[X],width,width);
             END;  {of FOR X}
           END   {of IF left}
          ELSE BEGIN
             pline[1] := pline[1] + title1;
             pline[2] := pline[2] + title2;
             pline[4] := pline[4] + 'Volume: ' + volume;
             pline[6] := pline[6] + refer;
           END;  {of ELSE}
          next := next_lab;
          IF NOT left THEN print_plines;
          left := NOT left;          {i.e. swap position flag}
        END;   {of WITH next^}
   END;   {of WHILE next}
IF NOT left THEN print_plines;       {in case there was an odd number}
END;    {of print_disk)labls}

         { ************************************************** }

PROCEDURE print_buyers_list;

VAR
lab_ptr : pointr;
buy_ptr : toe;
line, page_no, current_order, colum :  INTEGER;
out_put : TEXT;
out_file : STRING[13];
lpt_str :  STRING[1];

PROCEDURE header;

BEGIN
  WRITELN(out_put,'    RECORD OF PUBLIC DOMAIN SOFTWARE SHIPMENT');
  WRITELN(out_put,'    -----------------------------------------');
  WRITE(out_put,'                 Date: ', date);
  WRITE(out_put,'   Page No: ', page_no);
  IF disk_count <> 0 THEN BEGIN
       WRITELN(out_put, '     Total Disks used = ', disk_count);
       disk_count := 0;
    END
   ELSE   WRITELN(out_put);
  WRITELN(out_put);
  page_no := page_no + 1;
  line := 6;
END;   {of header}


BEGIN
IF to_disk THEN
    BEGIN
       CLRSCR;
       WRITE(#7);
       GOTOXY(10,10);WRITELN('INSERT DISK INTO DRIVE ',drive);
       GOTOXY(10,11);WRITELN('Then hit any key');
       REPEAT UNTIL KeyPressed;
       out_file := drive + date + '.PUB';
    END
 ELSE
    BEGIN
      select_printer(paper_printer);
      STR(paper_printer,lpt_str);
      out_file := 'LPT' + lpt_str;
    END;
ASSIGN(out_put, out_file);
REWRITE(out_put);
buy_ptr := buylist;
page_no := 1;
header;
WHILE buy_ptr <> NIL DO
  BEGIN
     WITH buy_ptr^ DO
       BEGIN
          IF line > 56  THEN
             BEGIN
                page_no := page_no + 1;
                header;
                WRITELN(out_put, CHR(12));
             END;   {of IF line}
          WRITELN(out_put,'Order No: ', orderno);
          WRITELN(out_put, '    ',name);
          WRITELN(out_put, '    ',adres1);
          WRITELN(out_put, '    ',adres2);
          WRITELN(out_put, '    ',adres3);
          current_order := orderno;
          buy_ptr := next_buy;
          line := line + 5;
       END;
     WRITELN(out_put);
     colum := 1;
     lab_ptr := lablist;
     WHILE lab_ptr <> NIL DO
      BEGIN
        IF lab_ptr^.order_no = current_order THEN
           BEGIN
             WRITE(out_put, lab_ptr^.volume,' ':(17 - LENGTH(lab_ptr^.volume)));
             colum := colum + 1;
             IF  colum > 4 THEN
                BEGIN
                  WRITELN(out_put);
                  line := line + 1;
                  colum := 1;
                END;  {of IF colum}
           END;   {of IF lab_ptr^}
        lab_ptr := lab_ptr^.next_lab;
      END;   {of WHILE lab_ptr}
      WRITELN(out_put); WRITELN(out_put); line := line + 2;
END;    {of WHILE buy_ptr}
WRITELN(out_put);                  {Empty buffer and eject}
WRITELN(out_put, CHR(12));
IF to_disk THEN
     CLOSE(out_put);
END;   {of print_buyerslist}

         { ************************************************** }

BEGIN  {Main Program}
  initialise;
  banner;
  get_buyer;
  CLRSCR;
  sortlabls;
  WRITE(CHR(7));
  GOTOXY(10,10);WRITELN('INSTALL LABELS INTO LPT',label_printer);
  IF (label_printer <> paper_printer) AND (NOT to_disk) THEN
    BEGIN
      GOTOXY(10,12);
      WRITELN('INSTALL PAPER INTO LPT',paper_printer);
    END;
  GOTOXY(10,14);WRITELN('GET THE PRINTER/S READY.');
  GOTOXY(10,17);WRITELN('Hit any key when ready. ');READ(Kbd, anykey);
  select_printer(label_printer);
  print_mail_labls;
  print_disk_labls;
  IF (label_printer = paper_printer) AND (NOT to_disk) THEN
    BEGIN
      CLRSCR;
      WRITE(CHR(7));
      GOTOXY(10,10);WRITELN('INSTALL PAPER INTO LPT',label_printer);
      WRITE('          Hit any key when ready. ');READ(Kbd, anykey);
    END;   {of IF label_printer}
  print_buyers_list;
END.  {of Main Program}